home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / search.tcl < prev    next >
Encoding:
Text File  |  1997-12-11  |  20.5 KB  |  718 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "search.tcl"
  6.  #                                    created: 13/6/95 {8:56:37 pm} 
  7.  #                                last update: 11/12/97 {11:11:21 am} 
  8.  #  
  9.  # Reorganisation carried out by Vince Darley with much help from Tom 
  10.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  11.  # Alpha is shareware; please register with the author using the register 
  12.  # button in the about box.
  13.  #  
  14.  #  Description: 
  15.  # 
  16.  # All procedures which deal with search/reg-search/grep type stuff
  17.  # in Alpha.
  18.  # ###################################################################
  19.  ##
  20.  
  21. namespace eval text {}
  22. namespace eval quote {}
  23. namespace eval file {}
  24.  
  25. proc quickFind {} {isearch}
  26. proc reverseQuickFind {} {rsearch}
  27. proc quickFindRegexp {} {regIsearch}
  28.  
  29. #================================================================================
  30. # 'greplist' and 'grepfset' are used for batch searching from the "find" dialog.
  31. #  Hence, you really shouldn't mess with them unless you know what you are doing.
  32. #================================================================================
  33. proc greplist {args} {
  34.     global tileLeft tileTop tileWidth tileHeight errorHeight
  35.  
  36.     set recurse [car $args]
  37.     set word [cadr $args]
  38.     set args [cddr $args]
  39.     
  40.     set num [expr [llength $args] - 2]
  41.     set exp [lindex $args $num]
  42.     set arglist [lindex $args [expr $num + 1]]
  43.     
  44.     set opened 0
  45.     set owin 0
  46.     set cid [scancontext create]
  47.  
  48.     set cmd [lrange $args 0 [expr $num - 1]]
  49.     eval scanmatch $cmd {$cid $exp {
  50.         if {!$word || [regexp -nocase "(^|\[^a-zA-Z0-9\])${exp}(\[^a-zA-Z0-9\]|\$)" $matchInfo(line)]} {
  51.             if (!$owin) {
  52.                 set owin 1
  53.                 win::SetProportions
  54.                 set w [new -n {* Batch Find *} -m Brws -g $tileLeft $tileTop $tileWidth $errorHeight]
  55.                 insertText "(<cr> to go to match)\r-----\r"
  56.                 set opened 1
  57.             }
  58.             set l [expr 20 - [string length [file tail $f]]]
  59.             insertText -w $w "\"[file tail $f]\"[format "%$l\s" ""]; Line $matchInfo(linenum): $matchInfo(line)\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$f\r"}
  60.         }
  61.     }
  62.  
  63.     foreach f $arglist {
  64.         message [file tail $f]
  65.         if {![catch {set fid [open $f]}]} {
  66.             scanfile $cid $fid
  67.             close $fid
  68.         }
  69.     }
  70.     scancontext delete $cid
  71.  
  72.     if {$opened} {
  73.         select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]
  74.         setWinInfo dirty 0
  75.         setWinInfo read-only 1
  76.     }
  77.     message ""
  78. }
  79.  
  80.  
  81. ## 
  82.  # -------------------------------------------------------------------------
  83.  # 
  84.  # "grepfset" --
  85.  # 
  86.  #  args: wordmatch ?-nocase? expression fileset
  87.  #  Obviously we ignore wordmatch
  88.  #  
  89.  #  If the 'Grep' box was set, then the search item is _not_ quoted.
  90.  #  
  91.  #  Non grep searching problems:
  92.  #  
  93.  #  If it wasn't set, then some backslash quoting takes place. 
  94.  #  (The chars: \.+*[]$^ are all quoted)
  95.  #  Unfortunately, this latter case is done incorrectly, so most
  96.  #  non-grep searches which contain a grep-sensitive character fail.
  97.  #  The quoting should use the equivalent of the procedure 'quote::Regfind'
  98.  #  but it doesn't quote () and perhaps other important characters.
  99.  #  
  100.  #  Even worse, if the string contained any '{' it never reaches this
  101.  #  procedure (there must be an internal error due to bad quoting).
  102.  # 
  103.  # -------------------------------------------------------------------------
  104.  ##
  105. proc grepfset {args} {
  106.     set num [expr [llength $args] - 2]
  107.     # the 'find' expression
  108.     set exp [lindex $args $num]
  109.     # the fileset
  110.     set fset [lindex $args [expr $num + 1]]
  111.     eval greplist 0 [lrange $args 0 [expr $num-1]] {$exp [getFileSet $fset]}
  112. }
  113.  
  114. proc grep {exp args} {
  115.     set files {}
  116.     foreach arg $args {
  117.         if {![catch {glob -t TEXT $arg} lst]} {
  118.             eval lappend files $lst
  119.         }
  120.     }
  121.     if {$files==""} {return $lst}
  122.     set cid [scancontext create]
  123.     scanmatch $cid $exp {
  124.         if {!$blah} {
  125.             set blah 1
  126.             set lines "(<cr> to go to match)\r"
  127.         }
  128.         set l [expr 20 - [string length [file tail $f]]]
  129.         append lines "\"[file tail $f]\"[format "%$l\s" ""]; Line $matchInfo(linenum): $matchInfo(line)\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$f\r"
  130.     }
  131.  
  132.     set blah 0
  133.     set lines ""
  134.  
  135.     foreach f $files {
  136.         if {![catch {set fid [open $f]}]} {
  137.             message [file tail $f]
  138.             scanfile $cid $fid
  139.             close $fid
  140.         }
  141.     }
  142.     scancontext delete $cid
  143.     return [string trimright $lines "\r"]
  144. }
  145.  
  146. proc grepnames {exp args} {
  147.     set files {}
  148.     foreach arg $args {
  149.         if {![catch {glob -t TEXT $arg} lst]} {
  150.             eval lappend files $lst
  151.         }
  152.     }
  153.     if {$files==""} {return $lst}
  154.     set cid [scancontext create]
  155.     scanmatch $cid $exp {
  156.         lappend filenames $f
  157.     }
  158.     set filenames ""
  159.     foreach f $files {
  160.         if {![catch {set fid [open $f]}]} {
  161.             message [file tail $f]
  162.             scanfile $cid $fid
  163.             close $fid
  164.         }
  165.     }
  166.     scancontext delete $cid
  167.     return $filenames
  168. }
  169.  
  170. ## 
  171.  # -------------------------------------------------------------------------
  172.  # 
  173.  # "grepsToWindow" --
  174.  # 
  175.  #  'args' is a list of items
  176.  # -------------------------------------------------------------------------
  177.  ##
  178. proc grepsToWindow {title args} {
  179.     global tileLeft tileTop tileWidth tileHeight errorHeight
  180.     win::SetProportions
  181.     new -n $title -g $tileLeft $tileTop $tileWidth $errorHeight -m Brws
  182.     eval insertText $args
  183.     select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]
  184.     winReadOnly
  185.     message ""
  186. }
  187.  
  188. proc findBatch {forward ignore regexp word pat} {
  189.     matchingLines $pat $forward $ignore $word $regexp 
  190. }
  191.  
  192. ## 
  193.  # -------------------------------------------------------------------------
  194.  #     
  195.  #    "containsSpace"    --
  196.  #    
  197.  #     Does the given    text contain any spaces?  In general we    don't complete
  198.  #     commands which    contain    spaces (although perhaps future    extensions
  199.  #     should    do this: e.g. cycle    through    'string    match',    'string    compare',…)
  200.  # -------------------------------------------------------------------------
  201.  ##
  202. proc containsSpace { cmd } { return [string match "*\[ \t\]*" $cmd] }
  203. proc containsReturn { cmd } { return [string match "*\r*" $cmd] }
  204.  
  205. ## 
  206.  # -------------------------------------------------------------------------
  207.  #     
  208.  #    "findPatJustBefore"    --
  209.  #    
  210.  #     Utility proc to check whether the first occurrence    of 'findpat'
  211.  #     to    the    left of    'pos' is actually an occurrence    of 'pat'. It can
  212.  #     be    used to    check if we're part    of an '} else {' (see TclelectricLeft)
  213.  #     or    in TeX mode    if we're in    the    argument of    a '\label{'    or '\ref{'
  214.  #     (see smartScripts)    for    example.
  215.  #     
  216.  #     A typical usage has the regexp    'pat' end in '$', so that it must
  217.  #     match all the text    up to 'pos'.  'matchw' can be used to store
  218.  #     the first '()'    pair match in the regexp.
  219.  #     
  220.  #     New: maxlook restricts how far this proc will search.  The default
  221.  #     is only 100 (not the entire file), after all this proc is supposed
  222.  #     to look 'just before'!
  223.  # -------------------------------------------------------------------------
  224.  ##
  225. proc findPatJustBefore { findpat pat {pos ""} {matchw ""} {maxlook 100} } {
  226.     if { $pos == "" } {set pos [getPos] }
  227.     if { $pos == [maxPos]} { incr pos -1}
  228.     if { $matchw != "" } { upvar $matchw word }
  229.     if {![catch {search -s -f 0 -r 1 -l [expr $pos - $maxlook] "$findpat" $pos} res]} {
  230.         if [regexp "$pat" [getText [lindex $res 0] $pos] dum word] {
  231.             return [lindex $res 0]
  232.         }
  233.     }
  234.     return
  235. }
  236. ## 
  237.  # -------------------------------------------------------------------------
  238.  # 
  239.  # "file::findAllInstances" --
  240.  # 
  241.  #  Returns all instances of a given pattern in a file.  This is a regexp
  242.  #  search, and the pattern must match all the way to the end of the 
  243.  #  file.  Here is an example usage:
  244.  #  
  245.  #      set pat2 {^.*\\(usepackage|RequirePackage)\{([^\}]+)\}(.*)$}
  246.  #      set subpkgs [file::findAllInstances $filename $pat2 1]
  247.  #  
  248.  #  Notice the pattern ends in '(.*)$', this is important.
  249.  #  Notice that since there is one extra '()' pair in the regexp,
  250.  #  we give '1' as the last argument.
  251.  #  
  252.  #  WARNING:  Calling this procedure incorrectly can easily result
  253.  #  in an infinite loop.  This will tend to crash Alpha and is hard
  254.  #  to debug using trace-dumps, because Alpha will tend to crash
  255.  #  whilst tracing too!  To debug, modify the 'while' loop so that it
  256.  #  also increments a counter, and stops after a few iterations.
  257.  # -------------------------------------------------------------------------
  258.  ##
  259. proc file::findAllInstances {filename searchString {extrabrackets 0}} {
  260.     # Get the text of the file to be searched:
  261.     if {[lsearch [winNames -f] $filename] >= 0} {
  262.         set fileText [getText -w $filename 0 [maxPos -w $filename]]
  263.     } elseif {[file exists $filename]} {
  264.         set fd [open $filename]
  265.         set fileText [read $fd]
  266.         close $fd
  267.     } else {
  268.         return ""
  269.     }
  270.     # Search the text for the search string:
  271.     while {[string length $fileText]} {
  272.         set dmy [lrange "d d d d d d" 0 $extrabrackets]
  273.         if [eval regexp [list $searchString] [list $fileText] $dmy match fileText] {
  274.             lappend matches $match
  275.         } else {
  276.             break
  277.         }
  278.     }
  279.     if [info exists matches] {
  280.         return $matches
  281.     } else {
  282.         return ""
  283.     }
  284. }
  285. # Look for pattern in filename after position afterPos and, if found, 
  286. # open the file quietly and select the pattern
  287. # author Jonathan Guyer
  288. proc selectPatternInFile {filename pattern {afterPos 0}} {
  289.     set searchResult [searchInFile $filename $pattern 1]
  290.     if {[lindex $searchResult 0] >= $afterPos} {
  291.         pushPosition
  292.         openFileQuietly $filename
  293.         eval select $searchResult
  294.         message "press <Ctl .> to return to original cursor position"
  295.         return 1
  296.     } else {
  297.         return 0
  298.     }
  299. }
  300.  
  301. proc text::replace {old new {fwd 1} {pos ""}} {
  302.     if {$pos == ""} {set pos [getPos]}
  303.     set m [search -s -f $fwd -m 0 -r 0 $old $pos]
  304.     eval replaceText $m [list $new]
  305. }
  306.  
  307.  
  308. proc isSelection {} {
  309.     return [expr [getPos] != [selEnd]]
  310. }
  311. proc searchStart {} {
  312.     global search_start
  313.     select [getPos]
  314.     setMark
  315.     if {[catch {goto $search_start}]} {message "No previous search"}
  316. }
  317. set {patternLibrary(Pascal to C Comments)}      { {\{([^\}]*)\}}    {/* \1 */}     }
  318. set {patternLibrary(C++ to C Comments)}            { {//(.*)}            {/* \1 */}     }
  319. set {patternLibrary(Space Runs to Tabs)}        { { +}                {\t}         }
  320.  
  321. proc getPatternLibrary {} {
  322.     global patternLibrary
  323.     
  324.     foreach nm [array names patternLibrary] {
  325.         lappend nms [concat [list $nm] $patternLibrary($nm)]
  326.     }
  327.     return $nms
  328. }
  329.  
  330. # This fails if, say, search string is '\{[^}]'
  331. # This is because the '}' ends the first argument because this
  332. # procedure is presumably called internally with incorrect quoting.
  333. proc rememberPatternHook {search replace} {
  334.     global patternLibrary modifiedArrayElements
  335.     if {[catch {set name [prompt "New pattern's name?" ""]}]} {
  336.         return ""
  337.     }
  338.     lappend modifiedArrayElements $name patternLibrary
  339.     set patternLibrary($name) [list $search $replace]
  340.     return $name
  341. }
  342.  
  343. proc deletePatternHook {} {
  344.     global patternLibrary modifiedArrayElements
  345.     set temp [list prompt "Delete which pattern?" [lindex [array names patternLibrary] 0] "Pats:"]
  346.     set name [eval [concat $temp [array names patternLibrary]]]
  347.     lappend modifiedArrayElements $name patternLibrary
  348.     unset patternLibrary($name)
  349. }
  350.  
  351. ## 
  352.  # -------------------------------------------------------------------------
  353.  # 
  354.  # "regIsearch" -- REGular expression Iterative SEARCH
  355.  # 
  356.  # This version allows class shorthands (\d \s \w \D \S \W), 
  357.  # word anchors (\b), and some aliases of the machine dependent 
  358.  # control characters (\a \f \e \n \r \t). Therefore, 
  359.  # we need two prompts, one for when we have a valid pattern, and one 
  360.  # for when the pattern has gone invalid (most likely due to starting 
  361.  # to enter one of the above patterns). 
  362.  # 
  363.  # The Return key aborts it  and the point goes back to the 
  364.  # original $pos. You can then use 'exchangePointAndMark' 
  365.  # (cntrl-x, cntrl-x -in emacs keyset) to jump back and forth 
  366.  # between where the search started from, to where the search was
  367.  # ended.
  368.  # 
  369.  # The Escape key or Mouse-click "exits" it, (as does "abortEm" -bound 
  370.  # to cntrl-g), as well as most modifier-key-combinations
  371.  # (except for Shift, and any combination whose  binding's 
  372.  # functionality makes sense -see regComp below). Also the 
  373.  # up & down Arrow keys, exit it. An exit differs from an abort in that, 
  374.  # in the former, the selection is left at the last search result.
  375.  # 
  376.  # 
  377.  # The next occurrence of the current pattern can be matched by typing 
  378.  # either control-s (to get the next occurence forward), or control-r 
  379.  # (to get the the next occurrence backward)
  380.  #
  381.  # Also, after aborting, the search string is left in the Find dialog,
  382.  # and so you can use 'findAgain', but, be aware that the Find dialog
  383.  # starts out with a default of <Grep=OFF>.
  384.  #  
  385.  # Original Author: Mark Nagata
  386.  # modifications  : Tom Fetherston
  387.  # -------------------------------------------------------------------------
  388.  ##
  389. proc regIsearch {} {
  390.  
  391.     set ignoreCase 0
  392.     set patt ""
  393.     set pos [getPos]
  394.     
  395.     set done 0
  396.     while {!$done} {
  397.         # check pattern validatity
  398.         if {[catch {regexp $patt {} dmy} dmy]} {        
  399.             set prompt "building->: $patt"
  400.         } else {
  401.             set prompt "regIsearch: $patt"
  402.         } 
  403.         switch -- [catch {statusPrompt $prompt regComp} res] {
  404.           0 {
  405.             # got a keystroke that triggered a normal end (e.g. <return>)
  406.             goto $pos
  407.             message "Aborted: $patt"
  408.             return
  409.           }
  410.           1 {
  411.             # an error was generated
  412.             if [string match "missing close-brace" $res] {
  413.                 # must have typed a slash, so:
  414.                 append patt "\\"
  415.                 continue
  416.             } else {
  417.                  # alertnote $res
  418.                 set done 1
  419.             }
  420.             
  421.           }
  422.           default {
  423.             set done 1
  424.           }
  425.         }
  426.         
  427.     }
  428.     
  429.     message " Exited: $patt"
  430. }
  431.  
  432.  
  433. ## 
  434.  # -------------------------------------------------------------------------
  435.  # 
  436.  # "regComp" -- REGisearch COMmand line input character Processor
  437.  # 
  438.  #  This proc handles each keypress while running a regIsearch. It has been 
  439.  #  modified from Mark Nagata's original to provide next ocurrence 
  440.  #  before/after current, and support for key bindings whose navigation or 
  441.  #  text manipulation functionality makes sense with respect to a regIsearch.
  442.  #  
  443.  #  closest occurence before current match    
  444.  #    - command-option g & cntrl-r (mnemonic 'reverse')
  445.  #  closest occurence after current match
  446.  #    - command g & cntrl-s (mnemonic 'successor')
  447.  #  
  448.  #                         Text Naviagation
  449.  #  forwardChar (aborts and leaves cursor after last match)
  450.  #    - right arrow & cntrl-f (emacs)
  451.  #  backwardChar (aborts and leaves cursor before last match)
  452.  #    - left arrow & cntrl-b (emacs)
  453.  #  beginningOfLine (aborts and moves cursors to the start of the line 
  454.  #      containing the last match)
  455.  #    - cmd left arrow & cntrl-a (emacs)
  456.  #  beginningOfLine (aborts and moves cursors to the start of the line 
  457.  #      containing the last match)
  458.  #    - cmd right arrow & cntrl-e (emacs)
  459.  #  
  460.  #                         Text Manipulation
  461.  #  deleteSelection (aborts and deletes selection)
  462.  #    - cntrl-d (emacs)
  463.  #  killLine (aborts and deletes from start of selection to end of line)
  464.  #    - cntrl-k (emacs)
  465.  #  
  466.  # -------------------------------------------------------------------------
  467.  ##
  468. proc regComp {curr {key 0}} {
  469.     set direction {}
  470.     
  471.     set mod [getModifiers]
  472.     # build a string that represents all the modifiers pressed:
  473.     # checking in this order cmd, shift, option, and ctrl
  474.     if [expr $mod & 1] { append t "c" } else { append t "_" }
  475.     if [expr $mod & 34] { append t "s" } else { append t "_" }
  476.     if [expr $mod & 72] { append t "o" } else { append t "_" }
  477.     if [expr $mod & 144] { append t "z" } else { append t "_" }
  478.  
  479.     scan $key %c decVal
  480.     
  481.     switch -- $t {
  482.       "____" {
  483.         switch -- $decVal {
  484.           29 {forwardChar ;         break; # right arrow; }
  485.           28 {backwardChar ;         break; # left arrow; }
  486.           30 {                        break; # up arrow; }
  487.           31 {                        break; # down arrow; }
  488.         }
  489.       }
  490.     }
  491.   
  492.     switch -- $t {
  493.       "____" - 
  494.       "_s__" {
  495.         upvar patt pat
  496.         if {$curr != ""} {
  497.             while {[string compare [string range $pat [string last $curr $pat] end] $curr] != 0} {
  498.                 set newEnd [expr [string length $pat] - 2]
  499.                 if {$newEnd < 0} {
  500.                     error "deleted past string start"
  501.                 } 
  502.                 set pat [string range $pat 0 $newEnd] 
  503.             }
  504.         } 
  505.         
  506.         set preAppend $pat
  507.         append pat $key
  508.         if {[catch {regexp $pat {} dmy} res]} {
  509.             message "building->: $preAppend"
  510.         } else {
  511.             message "regIsearch: $preAppend" 
  512.             upvar ignoreCase ign
  513.             set searchResult [search -n -f 1 -m 0 -i $ign -r 1 $pat [getPos]]
  514.             if {[llength $searchResult] == 0} {
  515.                 beep
  516.             } else {
  517.                 select [lindex $searchResult 0] [lindex $searchResult 1]
  518.             }
  519.         } 
  520.         return $key
  521.         
  522.       }
  523.       "c___" {
  524.         switch -- $decVal {
  525.           103 { set direction fwd;        # (cmd g); }
  526.           28 {beginningOfLine ;     break; # cmd left arrow; }
  527.           29 {endOfLine ;         break; # cmd right arrow; }
  528.         }
  529.         
  530.       }
  531.       "___z" {
  532.         # If the user is using the emacs key bindings, check for ones that 
  533.         # make sense. All other control key combinations abort
  534.         if {[package::active emacs]} {
  535.             switch -- $decVal {
  536.               6 {forwardChar ;         break; # cntrl-f; }
  537.               2 {backwardChar ;     break; # cntrl-b; }
  538.               1 {beginningOfLine ;     break; # cntrl-a; }
  539.               5 {endOfLine ;         break; # cntrl-e; }
  540.               4 {deleteSelection ;     break; # cntrl-d; }
  541.               10 {killLine ;         break; # cntrl-k; }
  542.             }
  543.         } 
  544.         # See if user has requested to find another match, either searchForward 
  545.         # (cntrl-s) or reverseSearch (cntrl-r). Set flag accordingly
  546.         switch -- $decVal {
  547.           19 { set direction fwd; # (cntrl-s); }
  548.           18 { set direction bckwd; # (cntrl-r); }
  549.           default {return {} }
  550.         }
  551.       }
  552.       "c_o_" {
  553.         switch $decVal {
  554.           169 { set direction bckwd; # (cmd-opt 'g'); }
  555.           default {return {} }
  556.         }
  557.         
  558.       }
  559.       "default" {
  560.         beep
  561.         error "modifier combination has no meaningful bindings with respect to regIsearch"
  562.       }
  563.     }
  564.     # handle direction flag if it got set above
  565.     if {$direction != ""} {
  566.         upvar patt pat
  567.         upvar ignoreCase ign
  568.         if {[string match $direction fwd]} {
  569.             set dir 1
  570.             set search_start [expr [getPos] + 1]
  571.         } else {
  572.             set dir 0
  573.             set search_start [expr [getPos] - 1]
  574.         } 
  575.         set searchResult [search -n -f $dir -m 0 -i $ign -r 1 $pat $search_start]
  576.         if {[llength $searchResult] == 0} {
  577.             beep
  578.         } else {
  579.             select [lindex $searchResult 0] [lindex $searchResult 1]
  580.         }
  581.         return {}
  582.     } 
  583. }
  584.  
  585.  
  586. proc choicesProc {curr c} {
  587.     global choiceList
  588.     if {$c != "\t"} {return $c}
  589.     
  590.     set matches {}
  591.     foreach w $choiceList {
  592.         if {[string match "$curr*" $w]} {
  593.             lappend matches $w
  594.         }
  595.     }
  596.     if {![llength $matches]} {
  597.         beep
  598.     } else {
  599.         return [string range [largestPrefix $matches] [string length $curr] end]
  600.     }
  601.     return ""
  602. }
  603.  
  604.  
  605. proc sPromptChoices {msg def choiceListIn} {
  606.     global useStatusBar choiceList
  607.     set choiceList $choiceListIn
  608.     if {[catch {statusPrompt -f "$msg ($def): " choicesProc} ans]} {
  609.         error "cancel"
  610.     }
  611.     if {![string length $ans]} {return $def}
  612.     return $ans
  613. }
  614.  
  615. ## 
  616.  # ----------------------------------------------------------------------
  617.  #     
  618.  #    "file::searchAndHyperise"    --
  619.  #    
  620.  #     Scans through an entire file for a    particular string or
  621.  #     regexp, and attaches a    hyperlink of the specified form
  622.  #     (regsub'ed    if desired)    to the original    string.
  623.  #            
  624.  #    Side effects:
  625.  #     Many hyperlinks will be embedded in your file
  626.  #    
  627.  #    Arguments:
  628.  #     Look for 'text', replace with 'link', doing both with a regexp
  629.  #     if signified (regexp = 1), using colour 'col', and offsetting
  630.  #     the link start and end by 'startoff' and 'endoff' respectively.
  631.  #     This last bit is so you can search for a large pattern, but only
  632.  #     embed a link in a smaller part of it.
  633.  #     
  634.  #    Examples: 
  635.  #     see 'proc install::hyperiseUrls'
  636.  # ----------------------------------------------------------------------
  637.  ##
  638. proc file::searchAndHyperise { text link {regexp 0} {col 3} {startoff 0} {endoff 0}} {
  639.     set pos 0
  640.     catch {
  641.         while {[string length [set inds [search -s -f 1 -r $regexp $text $pos]]]} {
  642.             set from [lindex $inds 0]
  643.             set to [lindex $inds 1]
  644.             set realfrom $from
  645.             set realto $to
  646.             incr realfrom $startoff
  647.             incr realto $endoff
  648.             insertColorEscape $realfrom $col
  649.             if {$link != ""} {
  650.                 if $regexp {
  651.                     regsub $text [getText $from $to] "$link" llink
  652.                 } else {
  653.                     set llink $link
  654.                 }
  655.                 insertColorEscape $realfrom 15 "$llink"
  656.                 insertColorEscape $realto 12
  657.             }
  658.             insertColorEscape $realto 0
  659.             set pos $to
  660.         }    
  661.     }
  662.     refresh
  663. }
  664. proc file::multiSearchAndHyperise {args} {
  665.     while 1 {
  666.         set text [lindex $args 0]
  667.         set link [lindex $args 1]
  668.         set args [lrange $args 2 end]
  669.         if {$text == ""} {return}
  670.         file::searchAndHyperise $text $link
  671.     }
  672. }
  673.  
  674. proc nextFunc {} {
  675.     searchFunc 1
  676. }
  677.  
  678. proc prevFunc {} {
  679.     searchFunc 0
  680. }
  681.  
  682. proc searchFunc {dir} {
  683.     global funcExpr
  684.     set pos [getPos]
  685.     select $pos
  686.     if ($dir==1) {
  687.         incr pos
  688.     } else {
  689.         set pos [expr $pos-1]
  690.     }
  691.     if {![catch {search -s -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
  692.         eval select $res
  693.     }
  694. }
  695.  
  696. proc sPrompt {msg def} {
  697.     global useStatusBar
  698.     if {!$useStatusBar} {return [prompt $msg $def]}
  699.     if {[catch {statusPrompt "$msg ($def): "} ans]} {
  700.         error "cancel"
  701.     }
  702.     if {![string length $ans]} {return $def}
  703.     return $ans
  704. }
  705.  
  706. proc revertTheseFiles {flist} {
  707.     foreach f $flist {
  708.         foreach w [winNames -f] {
  709.             set ww $w
  710.             regsub { <\d+>$} $w {} w
  711.             if {$f == $w} {
  712.                 bringToFront $ww
  713.                 revert
  714.             }
  715.         }        
  716.     }
  717. }
  718.